home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Grab Bag
/
Shareware Grab Bag.iso
/
090
/
listsubs.arc
/
LISTSUBS.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1986-01-19
|
6KB
|
199 lines
program listSubs;
{
This program prints a listing of all procedure and function
declarations in a Pascal source program.
Author: Fritz Ziegler
Date: 7/15/84, modified 1/19/86
Application: All systems
Originally published in TUG Lines (Turbo User Group) Vol. 1, Issue 5
}
type
fil_type = text;
filname_type = string[14]; { x:yyyyyyyy.zzz }
fil_lin_type = string[255];
maxstring = string[255];
identifier_type = string[127];
var
fil : fil_type;
outfil : fil_type;
filname : filname_type;
outfilname : filname_type;
done,
error : boolean;
procedure close_files(var fil,outfil:fil_type);
begin
close(fil);
close(outfil);
end; { close_files }
procedure upc_filname(var filname:filname_type);
var
i : integer;
begin
for i := 1 to length(filname) do filname[i] := upcase(filname[i]);
end; { upc_filname }
procedure get_filnames(var filname,outfilname:filname_type;
var done,error:boolean);
var temp : filname_type;
begin
filname:=''; outfilname:='';
writeln;
write('List procedures and functions on what file (CR to quit) ? ');
readln(filname);
writeln;
if filname <> '' then
begin
upc_filname(filname);
if (pos('.',filname)-1 > 0) then
outfilname:=copy(filname,1,pos('.',filname)-1) + '.LST'
else outfilname:=filname + '.LST';
write('List to (CR to choose ',outfilname,', LPT1 for printer) ? ');
readln(temp);
if (temp <> '') then
begin
upc_filname(temp);
outfilname:=temp;
end;
if outfilname=filname then
begin
writeln('ERROR >> The source, ',filname,' = the destination, ',outfilname);
error:=true
end;
end { if filname <> '' then }
else done:=true
end; { get_filename }
procedure open_file(var filname:filname_type;var fil:fil_type;var error:boolean);
begin
{$I-}
assign(fil,filname);
reset(fil);
{$I+}
if ioResult <> 0 then
begin
error:=true;
writeln('ERROR >> File does not exist');
end;
end; { open_files }
procedure open_outfile(var outfilname:filname_type;var outfil:fil_type);
begin
assign(outfil,outfilname);
rewrite(outfil);
end;
procedure print_procfunc_list(var fil:fil_type;
filname:filname_type);
var
fil_lin : fil_lin_type;
first_word : identifier_type;
is_cont_lin : boolean;
function is_procfunc(var fil_lin:fil_lin_type;
var is_cont_lin:boolean):boolean;
procedure get_first_word(fil_lin:fil_lin_type;
var first_word:identifier_type);
label return;
var
i, i2 : integer;
begin { get_first_word }
first_word:='';
for i:=1 to length(fil_lin) do
begin
if fil_lin[i] <> ' ' then
begin
for i2:=i to length(fil_lin) do
begin
if fil_lin[i2] <> ' ' then
first_word:=concat(first_word,upcase(fil_lin[i2]))
else
begin
goto return;
end; { else }
end; { for }
end; { if }
end; { for }
return:
end; { get_first_word }
procedure set_cont_flag(fil_lin:fil_lin_type;
first_word:identifier_type;
var is_cont_lin:boolean);
begin { set_cont_flag }
if (first_word = 'PROCEDURE') or
(first_word = 'FUNCTION') or
(first_word = 'PROGRAM') then
if (pos('(',fil_lin) <> 0) and (pos(')',fil_lin) = 0) then
is_cont_lin:=true;
end; { set_cont_flag }
begin { is_procfunc }
get_first_word(fil_lin,first_word);
if not is_cont_lin then set_cont_flag(fil_lin, first_word,is_cont_lin);
if (first_word = 'PROCEDURE') or
(first_word = 'FUNCTION') or
(first_word = 'PROGRAM') or
(first_word = 'END.') or
is_cont_lin then
is_procfunc:=true
else is_procfunc:=false;
end; { is_procfunc }
procedure clrsav_cont_flag(fil_lin:fil_lin_type;
var is_cont_lin:boolean);
begin { clrsav_cont_flag }
if (pos(')',fil_lin) <> 0) then
is_cont_lin := false;
end; { clrsav_cont_flag }
begin { print_procfunc_list }
writeln(' *** LISTSUBS ***');
writeln;
writeln(' A list of subprograms for the file ',filname);
writeln;
writeln;
writeln(outfil,' *** LISTSUBS ***');
writeln(outfil);
writeln(outfil,' A list of subprograms for the file ',filname);
writeln(outfil);
writeln(outfil);
is_cont_lin:=false;
while not eof(fil) do
begin
fil_lin:='';
readln(fil,fil_lin);
if is_procfunc(fil_lin,is_cont_lin) then
begin
writeln(fil_lin);
writeln(outfil,fil_lin);
end; { if }
if is_cont_lin then clrsav_cont_flag(fil_lin,is_cont_lin);
end; { while }
end; { print_procfunc_list }
begin { main program }
done:=false;
repeat
error:=false;
get_filnames(filname,outfilname,done,error);
if (not done) and (not error) then
begin
open_file(filname,fil,error);
if not error then
begin
open_outfile(outfilname,outfil);
print_procfunc_list(fil,filname);
close_files(fil,outfil);
end;
end { if (not done) and (not error) then }
until done;
end. { listSubs }